perm filename PIC.F4[P,LCS] blob
sn#084636 filedate 1974-01-26 generic text, type T, neo UTF8
00100 C SHORT VERSION OF MANFRED'S TVIOF.F4: LOAD WITH PLOUX.F4 AND PLTMAN.F4
00150 C THIS DISPLAYS OR PLOTS PROCESSED FILES ONLY. 12/73
00200
00210 C TYPE <CR> TO REPEAT LAST FILE READ IN.
00220 C TYPE X TO EXIT, TYPE SAVE TO SAVE FILE FOR DRAWING PROG.
00230 C TYPE T TO TYPE LIST OF ALL YOUR CURRENT INPUT.
00240
00300 COMMON /EDGEC/ A0,A1,A2,A3,A4,A5,A6,A7,
00366 1 DEBUG,T(1),XP(1),YP(1),PARMAX,
00432 1 HALF,FILE,RR,COH,RX,RY,CL,SL,D,B,FOUND
00498
00500 DIMENSION IDP1(6000),JXX(4000),LIST(6,1000),LIST5(0/1000)
00532 EQUIVALENCE (JXX,IDP1(1001))
00548 COMMON /JDP/IDP1
00564 COMMON /LISTC/ LIST,LIST5,NEWEND,LO
00630
00696 COMMON/COMMAC/BCLIP,TCLIP,BITS,IWID,LINLEN,FLINE,LLINE,
00762 1 LSIDE,RSIDE,JCNT,HYSTAB(0/15)
00828
01026
01500 INTEGER FLINE,RSIDE,HYSTAB,TIM1,TIM2,FILEN,FILE,BITS
02200 CC LOGICAL FUNCTION ADMISS
02300 CC ADMISS(DTA)=DTA.EQ.-7.OR.(1.LE.DTA.AND.DTA.LE.10)
02350 BITS=4
12800 83 FORMAT(A5)
17700 204 FORMAT(' TYPE THE FILE NAME'/)
19000 202 FORMAT(' NEWEND=',I4/)
26200 330 TYPE 204
26300 ACCEPT 83,FILE
26850 4 REWIND 1
26900 CALL IFILE(1,FILE)
27000 READ(1) FILEN,RR,FLINE,LLINE,LSIDE,RSIDE,NEWEND,
27100 1 ((LIST(I,N),I=1,6),N=1,NEWEND)
27200 TYPE 202,NEWEND
27300 IF(NEWEND.GE.1000)GO TO 252
27400 DO 335 I=NEWEND*6+1,6000
27500 335 LIST(I,1)=0
27900 252 CALL PIC2
28000 13 TYPE 204
28100 ACCEPT 83,FILE
28150 IF(LOOKD(FILE))GO TO 10
28200 14 REWIND 1
28300 CALL OFILE(1,FILE)
28350 IF(JCNT.GT.4000)JCNT=4000
28400 WRITE(1)JCNT,(JXX(K),K=1,JCNT),FLINE,LLINE,LSIDE,RSIDE,K
28500 CALL EXIT
28600 10 TYPE 11,FILE
28700 11 FORMAT(' WRITE OVER ',A5,'? '/$)
28800 ACCEPT 12,K
28900 12 FORMAT(A1)
29000 IF(K.EQ.'N')GO TO 13
29100 GO TO 14
29200 END
30000 SUBROUTINE PIC2
30100
30200 CC COMMON/DP/IDP(4000)
30300 CC CALL DPYSET(1,IDP,4000)
30400
30500 EQUIVALENCE(LIST,CURV),(JXX,IDP1(1001))
30600
30700 DIMENSION CURV(2,3000),HIST(0/63),DIF(3)
30800
30900 COMMON /EDGEC/ A0,A1,A2,A3,A4,A5,A6,A7,
31000 1 DEBUG,TE(1),XP(1),YP(1),PARMAX,
31100 1 HALF,FILE,RR,COH,RX,RY,CL,SL,D,B,FOUND
31200
31210 COMMON /JDP/IDP1
31220 DIMENSION IDP1(6000),JXX(4000)
31300 COMMON /LISTC/LIST(6,1000),LIST5(0/1000),NEWEND,LO
31400
31500 COMMON/COMMAC/BCLIP,TCLIP,BITS,IWID,LINLEN,FLINE,LLINE,
31600 1 LSIDE,RSIDE,JCNT,HYSTAB(1)
31700
31800 INTEGER FI,FILEN,EWE,HIST,BITS,
31900 1 XIX,XI,FLINE,RSIDE,
32000 1 NUM2,NUM3,IDD,PL,LIST5,X
32100
32200 REAL LIST,RR,CL,SL,LEAP,LEA6,LEA3,CONST,FRAC,
32300 1 RX,RY,TEXT,TH,W1,W2,B1,B2,V1,V2,
32400 1 LV,LW,LB,D1,D2,CURV,T,X1,X2,A1,A2,C1,C2,MA,LC,
32500 1 D,B,DIF,B0,BB1,C3,C4
32600 DATA JCNT/0/,RTO/6./
32700 DIF(1)=0.0
32800 B0=0.0
32900 BB1=2**BITS-1
33000 CONST=2.41
33100 IF(FLINE.EQ.0.AND.LSIDE.EQ.0.AND.
33200 1 LLINE.EQ.252.AND.RSIDE.EQ.251) CONST=CONST*.6667
33300 68 LEAP=(RR/2.+CONST)*RTO
33400 LEA6=LEAP/6.
33500 LEA3=LEAP/3.
33600 TH=(LEAP**2)*0.075
33700
33800 DO 70 IDD=0,63
33900 70 HIST(IDD)=0
34000 FRAC=64.0/FLOAT(2**BITS)
34100 DO 100 XIX=1,NEWEND
34200 IDD=IFIX(LIST(5,XIX)*FRAC+0.5)
34300 IF(0.GT.IDD) IDD=0
34400 IF(63.LT.IDD) IDD=63
34500 HIST(IDD)=HIST(IDD)+1
34600 100 CONTINUE
34700
34800 DO 110 IDD=1,63
34900 110 HIST(IDD)=HIST(IDD)+HIST(IDD-1)
35000 IF(HIST(63).NE.NEWEND) PAUSE 'ERROR IN PLOU'
35100 NUM2=IFIX(FLOAT(NEWEND)/3.+0.5)
35200 NUM3=IFIX(FLOAT(NEWEND)*2./3.+0.5)
35300 DO 121 IDD=1,63
35400 IF(NUM2.GE.(HIST(IDD)+HIST(IDD-1))/2) DIF(2)=FLOAT(
35500 1 IDD)/FRAC
35600 121 IF(NUM3.GE.(HIST(IDD)+HIST(IDD-1))/2) DIF(3)=FLOAT(
35700 1 IDD)/FRAC
35800
35900 DO 123 I=0,1000
36000 123 LIST5(I)=1
36100
36200 125 XI=1
36300 DO 120 XIX=1,NEWEND
36400 D=LIST(5,XIX)
36500 B=LIST(6,XIX)
36600 IF(((B+D.LT.B0+DIF(1)).OR.(B.GT.BB1-DIF(1)
36700 1 )).OR.(D.LT.DIF(1))) GOTO 120
36800 RX=LIST(1,XIX)*RTO
36900 RY=LIST(2,XIX)*RTO
37000 CL=LIST(3,XIX)*LEA6
37100 SL=LIST(4,XIX)*LEA6
37200 CURV(1,XI)=RX-SL
37300 CURV(2,XI)=RY+CL
37400 CURV(3,XI)=RX+SL
37500 CURV(4,XI)=RY-CL
37600 IF(((B+D.LT.B0+DIF(2)).OR.(B.GT.BB1-DIF(2)
37700 1 )).OR.(D.LT.DIF(2))) GOTO 118
37800 LIST5((XI-1)/2)=2
37900 IF(((B+D.LT.B0+DIF(3)).OR.(B.GT.BB1-DIF(3)
38000 1 )).OR.(D.LT.DIF(3))) GOTO 118
38100 LIST5((XI-1)/2)=3
38200 118 XI=XI+2
38300 120 CONTINUE
38400
38500 DO 400 PL=1,3
38600
38700 GOTO(140,130,130),PL
38800 130 X=1
38900 DO 136 XI=1,EWE-3,2
39000 I=(XI-1)/2
39100 IF(LIST5(I).LT.PL) GOTO 136
39200 C1=CURV(1,XI)
39300 C2=CURV(2,XI)
39400 C3=CURV(3,XI)
39500 C4=CURV(4,XI)
39600 CURV(1,X)=C1
39700 CURV(2,X)=C2
39800 CURV(3,X)=C3
39900 CURV(4,X)=C4
40000 LIST5((X-1)/2)=LIST5(I)
40100 X=X+2
40200 136 CONTINUE
40300 XI=X
40400
40500 140 EWE=XI+1
40600 FI=1
40700 LA=0
40800 DO 135 XIX=4,EWE,2
40900 LI=XIX-2
41000
41100 IF((2.*CURV(1,LI)-CURV(1,XIX-3)-2.*CURV(1,XIX-1)+
41200 1 CURV(1,XIX))**2+(2.*CURV(2,LI)-CURV(2,XIX-3)-
41300 1 2.*CURV(2,XIX-1)+CURV(2,XIX))**2.LT.TH) GOTO 135
41400
41500 LA=LI
41600 KI=FI+1
41700 IF(KI.EQ.LA) GOTO 200
41800 IF(PL.GT.1) GOTO 200
41900
42000 CURV(1,FI)=CURV(1,FI)*1.5-CURV(1,KI)*0.5
42100 CURV(2,FI)=CURV(2,FI)*1.5-CURV(2,KI)*0.5
42200 CURV(1,LA)=CURV(1,LA)*1.5-CURV(1,LA-1)*0.5
42300 CURV(2,LA)=CURV(2,LA)*1.5-CURV(2,LA-1)*0.5
42400
42500 200 CALL PACK(JCNT,CURV(1,FI),CURV(2,FI),3)
42600 2002 NI=LA-2
42700 JI=FI-1
42800 DO 210 I=JI,NI
42900 KI=I+1
43000 LI=KI+1
43100 MI=LI+1
43200 B1=CURV(1,LI)-CURV(1,KI)
43300 B2=CURV(2,LI)-CURV(2,KI)
43400 IF (I.EQ.JI) GOTO 202
43500 A1=CURV(1,KI)-CURV(1,I)
43600 A2=CURV(2,KI)-CURV(2,I)
43700 GOTO 204
43800 202 A1=B1
43900 A2=B2
44000 204 IF (I.EQ.NI) GOTO 206
44100 C1=CURV(1,MI)-CURV(1,LI)
44200 C2=CURV(2,MI)-CURV(2,LI)
44300 GOTO 208
44400 206 C1=B1
44500 C2=B2
44600 208 MA=A1**2+A2**2
44700 LB=B1**2+B2**2
44800 LC=C1**2+C2**2
44900 V1=A1*LB+B1*MA
45000 V2=A2*LB+B2*MA
45100 W1=B1*LC+C1*LB
45200 W2=B2*LC+C2*LB
45300 LV=SQRT(V1**2+V2**2)
45400 LW=SQRT(W1**2+W2**2)
45500 LB=SQRT(LB)
45600 CC IF (LV.LT.1.E-6.OR.LW.LT.1.E-6) PAUSE 'LV LW'
45700 AA=LB*.5858
45800 AB=AA/LW
45900 AA=AA/LV
46000 V1=V1*AA
46100 V2=V2*AA
46200 W1=W1*AB
46300 W2=W2*AB
46400 D1=B1-V1-W1
46500 D2=B2-V2-W2
46600
46700 DO 220 K=1,8
46800 T=FLOAT(K)/8.
46900 T1=2.-T
47000 T2=3.-2.*T
47100 220 CALL PACK(JCNT,(CURV(1,KI)+(V1*T1+(W1+D1*T2)*T)*T+.5),
47200 1 (CURV(2,KI)+(V2*T1+(W2+D2*T2)*T)*T+.5),2)
47300 210 CONTINUE
47400
47500 135 FI=LA+1
47600 IF(PL.EQ.3)RETURN
47700 JCNT=JCNT+1
47800 400 JXX(JCNT)=-1
47900 C -1 INDICATES 2ND OR 3RD RUN TO BEGIN NOW.
48000 1001 FORMAT(A1)
48100 END
48200
48300 SUBROUTINE PACK(J,X,Y,N)
48400 COMMON /JDP/IDP1
48450 DIMENSION IDP1(6000),JXX(4000)
48460 EQUIVALENCE (JXX,IDP1(1001))
48600 DATA II/20/
48700 IF(J.GE.12000)RETURN
48800 L=Y
48900 M=X
49000 4 IF(N.EQ.3)GO TO 5
49100 IX=IX+1
49200 IF(IX.LT.II)RETURN
49300 IX=0
49400 C DISPLAYS EVERY IIth LINE
49500 IF((M.EQ.MA.AND.M.EQ.MB).OR.(L.EQ.LA.AND.L.EQ.LB))J=J-1
49600 C TO AVOID SEVERAL POINTS ON STRAIGHT LINE
49700 MB=MA
49800 LB=LA
49900 MA=M
50000 LA=L
50100 5 K=M*100000+L
50200 3 IF(N.EQ.3)K=-K
50300 CC IF(N.EQ.3)GO TO 8
50400 CC IF(II.NE.J)CALL AVECT(M-380,L-200)
50500 CC CALL DPYOUT(1)
50600 CC GO TO 9
50700 CC8 CALL AIVECT(M-380,L-200)
50800 9 J=J+1
50900 JXX(J)=K
51000 CC II=J
51100 CC1 FORMAT(I5,I,I5,I4)
51200 END